Mac Mania 2/MacMania 2.toast/Demo's/Tools&Utilities/Programming/PowerLisp 1.1/Library/cl.lisp

Text File | 1994-04-25 | 40.5 KB | 1,585 lines | [TEXT/ROSA]

;;;
;;;        Copyright © 1994 Roger Corman.  All rights reserved.
;;;

;
;        Lisp standard functions and macros to be loaded at startup.
;

(eval-when (:compile-toplevel :load-toplevel :execute)
    (in-package :common-lisp))

(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(    when
            unless
            prog1
            prog2
            loop
            assert
            warn
            push
            pushnew
            pop
            ecase
            incf
            decf
            remf
            multiple-value-list
            multiple-value-setq
            multiple-value-bind
            functionp keywordp arrayp packagep bit-vector-p
            string
            position position-if position-if-not
            find find-if find-if-not
            count count-if count-if-not
            fill replace
            mismatch search
            svref array-rank-limit array-dimension-limit array-total-size-limit
            print
            prin1
            princ
            mapcan
            mapcon
            copy-alist
            read-from-string
            with-output-to-string
            read-function
            prompt *prompt*
            disassemble
            print-addr
            print-code
            copyright
            require
            provide
            defasm
            hex
            compile
            compile-file
            compile-without-assembling
            identity
            finish-output force-output clear-output
            parse-integer
            psetq
            do
            do*
            *features*
            *modules*
            *load-verbose*
            *load-print*
            *print-radix*
            *print-circle*
            *print-pretty*
            *print-length*
            *print-gensym*
            *print-array*
            *gc-verbose*
            *lisp-file-extension*
            *lisp-compiled-file-extension*
            *library-directory*
            *top-level*
            pi
            internal-time-units-per-second
            defun defmacro deftype defstruct defpackage
            time
            ffloor fceiling ftruncate fround
            signum
            typecase
            describe
            get-properties copy-symbol
            do-symbols do-all-symbols do-external-symbols find-all-symbols
            logtest cis asinh acosh atanh
            butlast nbutlast list-length
            error-stack))
) ;; close eval-when

(setq *print-case* :downcase)    ; can be :upcase, :downcase or :capitalize

; Some Common Lisp special variables
(defvar *features* '(powerlisp))
(defvar *modules* nil)
(defvar *read-suppress* nil)
(defvar *top-level* nil)
(defvar *print-radix* nil)
(defvar *print-circle* nil)
(defvar *print-pretty* nil)
(defvar *print-length* nil)
(defvar *print-gensym* t)
(defvar *print-array* t)

;
;    The *library-directory* special variable is used by
;    the 'require' function to figure out where to load
;    requested modules from.
;
(defconstant *library-directory* ":library:")
(defconstant *lisp-file-extension* ".lisp")
(defconstant *lisp-compiled-file-extension* ".fasl")

(defun compile (name &optional definition)
    "Usage: (COMPILE function-name &optional lambda)"
    (require :compiler)
    (compiler::compile-it name definition))

(defun compile-file (input-file &key (output-file "untitled.fasl") print)
    "Usage: (COMPILE-FILE input-filename :OUTPUT-FILE output-filename)"
    (require :compiler)
    (editor-message (format nil "Compiling file ~A…" input-file))
    (compiler::compile-the-file input-file output-file print))

(defun compile-without-assembling (name &optional definition)
    "Usage: (COMPILE-WITHOUT-ASSEMBLING function-name &optional lambda)"
    (require :compiler)
    (compiler::compile-without-assembling-it name definition))

;
;    Common Lisp 'prog1' macro
;
(defmacro prog1 (first-x &rest rest-x)
    `(let* ((a1 ,first-x))
        ,@rest-x
        a1))

;
;    Common Lisp 'prog2' macro
;
(defmacro prog2 (first-x second-x &rest rest-x)
    `(let* ((a1 ,first-x) (a2 ,second-x))
        ,@rest-x
        a2))

;
;    Simple version of LOOP macro
;
(defmacro loop (&rest forms)
    (dolist (f forms)
        (if (symbolp f)        ;; need expanded macro
            (progn
                (require :loop)
                (return-from loop `(loop ,@forms)))))
    (let ((sym (gensym)))
        `(block nil (tagbody ,sym ,@forms (go ,sym)))))

;
;    Common Lisp 'assert' macro
;
(defmacro assert (x)
    `(if (null ,x) (error "Assertion failed")))

;
;    Common Lisp 'warn' function.
;    This should really go to error-output stream.
;
(defun warn (format-string &rest args)
    (format t "~%Warning: ")
    (apply #'format t format-string args)
    (format t "~%"))

;
;    Common Lisp 'require' function.
;    The path-name option is not implemented yet.
;
(defun require (module-name &optional path-name)
    (if path-name
        (progn
            (format t "require: path-name option not implemented~%")
            (format t "Searching default directory: ~A~%"
                *library-directory*)))

    (if (symbolp module-name)
        (setq module-name (symbol-name module-name)))

    ;; load the module if necessary
    (if (not (member module-name *modules* :test #'equal))
        (let ((filename (concatenate 'string *library-directory*
                    module-name *lisp-file-extension*))
              (compiled-filename (concatenate 'string *library-directory*
                      module-name *lisp-compiled-file-extension*)))
            (cond
                ((probe-file compiled-filename)
                 (load compiled-filename))
                ((probe-file filename)
                 (load filename))
                (t (error "Can't locate the required module: ~A~%" module-name)))))

    ;; if it still doesn't exist, signal an error
    (if (not (member module-name *modules* :test #'equal))
        (error "Could not provide the required module: ~A~%" module-name))

    module-name)

;
;    Common Lisp 'provide' function.
;
(defun provide (module-name)
    (if (symbolp module-name)
        (setq module-name (symbol-name module-name)))
    (push module-name *modules*)
    module-name)

(defun %once-only-forms (form)
    (let*
        ((args (rest form)) ; raw form arguments
         (letlist
            (let ((newlist nil))
                (dolist (x form)
                    (when (consp x)
                        (push `(,(gensym) ,x) newlist)))
                (nreverse newlist)))
         (revlist
            (let ((newlist nil))
                (dolist (x letlist)
                    (push (cons (second x) (first x)) newlist))
                (nreverse newlist)))
         (newform (cons (first form) (sublis revlist args))))
        (cons letlist newform)))

(defmacro incf (form &optional (delta 1))
    (if (and (consp form) (some #'consp form))
        (let ((retval (%once-only-forms form)))
            `(let ,(car retval)
                (setf ,(cdr retval) (+ ,(cdr retval) ,delta))))
        `(setf ,form (+ ,form ,delta))))

(defmacro decf (form &optional (delta 1))
    (if (and (consp form) (some #'consp form))
        (let ((retval (%once-only-forms form)))
            `(let ,(car retval)
                (setf ,(cdr retval) (- ,(cdr retval) ,delta))))
        `(setf ,form (- ,form ,delta))))

(defmacro push (val form)
    (if (and (consp form) (some #'consp form))
        (let ((retval (%once-only-forms form)))
            `(let ,(car retval)
                (setf ,(cdr retval) (cons ,val ,(cdr retval)))))
        `(setf ,form (cons ,val ,form))))

(defmacro pop (form)
    (if (and (consp form) (some #'consp form))
        (let ((retval (%once-only-forms form)))
            `(let ,(car retval)
                (prog1 (first ,(cdr retval))
                    (setf ,(cdr retval) (rest ,(cdr retval))))))
        `(prog1 (first ,form) (setf ,form (rest ,form)))))

(defmacro pushnew (val form &rest rest)
    (if (and (consp form) (some #'consp form))
        (let ((retval (%once-only-forms form)))
            `(let ,(car retval)
                (setf ,(cdr retval) (adjoin ,val ,(cdr retval) ,@rest))))
        `(setf ,form (adjoin ,val ,form ,@rest))))


;    Common Lisp 'remf' macro
;    This currently does not completely conform to the standard because
;    subexpressions are evaluated twice.
;
(defmacro remf (place indicator)
    `(multiple-value-bind (plist flag)
        (%remove-property ,place ,indicator)
        (setf ,place plist)
        flag))

;
;    Common Lisp 'multiple-value-list' macro
;
(defmacro multiple-value-list (form)
    `(multiple-value-call #'list ,form))

;
;    Common Lisp 'multiple-value-setq' macro
;
(defmacro multiple-value-setq (varlist form)
    (let ((setq-forms nil)
          (value-list-sym (gensym))
          (return-form-sym (gensym)))
        (do ((v varlist (cdr v)) (count 0 (1+ count)))
            ((null v))
            (push
                `(setq ,(car v) (nth ,count ,value-list-sym))
                setq-forms))
        `(let* ((,value-list-sym (multiple-value-list ,form))
                (,return-form-sym (car ,value-list-sym)))
            ,@(reverse setq-forms)
            ,return-form-sym)))

;
;    Common Lisp 'multiple-value-bind' macro
;
(defmacro multiple-value-bind (vars value-form &rest forms)
    (let ((sym (gensym)))
        `(let ,vars
            (multiple-value-setq ,vars ,value-form)
            ,@forms)))

(defmacro psetq (&rest args)
    (let ((syms nil)
          (values nil)
          (newsym (gensym)))
        (prog* ((a args) (index 0))
            loop-label
            (if (null a) (return))
            (if (not (symbolp (car a)))
                (error "Not a symbol: ~A" (car a)))
            (if (not (consp (cdr a)))
                (error "symbol ~A without value in psetq form" (car a)))
            (push `(setq ,(car a) (nth ,index ,newsym)) syms)
            (push (cadr a) values)
            (setq a (cddr a))
            (setq index (1+ index))
            (go loop-label))
        (setq syms (nreverse syms))
        (setq values (nreverse values))
        `(let ((,newsym (list ,@values)))
            (progn ,@syms) nil)))

(defmacro do* (varlist return-clause &rest body)
    (let ((local-vars nil)
          (inc-expressions nil)
          (label (gensym)))

        ;; collect variable and increment expressions
        (prog* ((v varlist) sym)
            loop-label
            (if (null v) (return))
            (setq sym (car v))
            (if (consp sym)
                (if (consp (cdr sym))
                        (progn
                            (push (list (car sym) (cadr sym)) local-vars)
                            (if (consp (cddr sym))
                                (progn
                                    (push (car sym) inc-expressions)
                                    (push (caddr sym) inc-expressions))))
                    (push (car sym) local-vars))
                (if (not (symbolp sym))
                    (error "Improper 'do*' expression--should be a symbol: ~A" sym)
                    (push sym local-vars)))
            (setq v (cdr v))
            (go loop-label))

        (setq local-vars (nreverse local-vars))
        (setq inc-expressions `(setq ,@(nreverse inc-expressions)))
        (if (not (consp return-clause))
            (error "Invalid return clause in 'do*' expression: ~A"
                return-clause))
        (setq return-clause
            `(if ,(car return-clause) (return (progn ,@(cdr return-clause)))))

        `(prog* ,local-vars
               ,label
               ,return-clause
               ,@body
               ,inc-expressions
               (go ,label))))

(defmacro do (varlist return-clause &rest body)
    (let ((local-vars nil)
          (inc-expressions nil)
          (label (gensym)))

        ;; collect variable and increment expressions
        (prog* ((v varlist) sym)
            loop-label
            (if (null v) (return))
            (setq sym (car v))
            (if (consp sym)
                (if (consp (cdr sym))
                        (progn
                            (push (list (car sym) (cadr sym)) local-vars)
                            (if (consp (cddr sym))
                                (progn
                                    (push (car sym) inc-expressions)
                                    (push (caddr sym) inc-expressions))))
                    (push (car sym) local-vars))
                (if (not (symbolp sym))
                    (error "Improper 'do' expression--should be a symbol: ~A" sym)
                    (push sym local-vars)))
            (setq v (cdr v))
            (go loop-label))

        (setq local-vars (nreverse local-vars))
        (setq inc-expressions `(psetq ,@(nreverse inc-expressions)))
        (if (not (consp return-clause))
            (error "Invalid return clause in 'do' expression: ~A"
                return-clause))
        (setq return-clause
            `(if ,(car return-clause) (return (progn ,@(cdr return-clause)))))

        `(prog ,local-vars
               ,label
               ,return-clause
               ,@body
               ,inc-expressions
               (go ,label))))

;
;    Common Lisp 'ecase' macro.
;
(defmacro ecase (key &rest clauses)
    `(case ,key ,@clauses (otherwise (error "No matching key found in ecase form."))))

;
;    Set up the reader macro which allows for #| ... |# type comments
;
(set-dispatch-macro-character #\# #\|
    #'(lambda (stream char int)
            (do ((c (read-char stream) (read-char stream)))
                 ((and (char= c #\|) (char= (peek-char nil stream) #\#))
                         (read-char stream)(values)) nil)))

;
;    Set up the reader macro which allows for #+ and #- conditional reads
;
(defun %features-member (feature-list)
    (if (symbolp feature-list)
        (return (member feature-list *features*)))
    (if (consp feature-list)
        (ecase (car feature-list)
            (and (every #'%features-member (cdr feature-list)))
            (or  (some #'%features-member (cdr feature-list)))
            (not (notany #'%features-member (cdr feature-list))))
        (error "~A is not a valid feature." feature-list)))


(set-dispatch-macro-character #\# #\+
    #'(lambda (stream char int)
        (let ((feature (read stream)))
            (if (%features-member feature)
                (return (read stream)))

            ; else need to skip over the next expression
            (let ((*read-suppress* t))
                (read stream))
            (return (values)))))

(set-dispatch-macro-character #\# #\-
    #'(lambda (stream char int)
        (let ((feature (read stream)))
            (if (not (%features-member feature))
                (return (read stream)))

            ; else need to skip over the next expression
            (let ((*read-suppress* t))
                (read stream))
            (return (values)))))

;
;    Reader macro which handles #. syntax.
;
(set-dispatch-macro-character #\# #\.
    #'(lambda (stream char int)
        (eval (read stream))))

;
;    Set up reader macro for octal, binary and hex numbers
;    #onnn -> octal, #bnnn ->binary, #xnnn ->hex
;
(set-dispatch-macro-character #\# #\O
    #'(lambda (stream char int)
        (let ((*read-base* 8))
            (read stream))))

(set-dispatch-macro-character #\# #\B
    #'(lambda (stream char int)
        (let ((*read-base* 2))
            (read stream))))

(set-dispatch-macro-character #\# #\X
    #'(lambda (stream char int)
        (let ((*read-base* 16))
            (read stream))))

(set-dispatch-macro-character #\# #\R
    #'(lambda (stream char int)
        (let ((*read-base* int))
            (read stream))))

;
;    SETF expansion functions
;
(defmacro defsetf (sym func)
    `(putprop ',sym 'cl::_setf_expansion_ ',func))

(defsetf symbol-value set)
(defsetf symbol-function $set-symbol-function)
(defsetf symbol-plist %set-symbol-plist)
(defsetf macro-function $set-macro-function)
(defsetf documentation put-documentation)
(defsetf char common-lisp::%setchar)
(defsetf schar common-lisp::%setchar)
(defun %setcar (c x) (rplaca c x) x)
(defsetf car %setcar)
(defun %setcdr (c x) (rplacd c x) x)
(defsetf cdr %setcdr)
(defsetf rest %setcdr)
(defun %setcaar (x val) (setf (car (car x)) val))
(defsetf caar %setcaar)
(defun %setcadr (x val) (setf (car (cdr x)) val))
(defsetf cadr %setcadr)
(defun %setcdar (x val) (setf (cdr (car x)) val))
(defsetf cdar %setcdar)
(defun %setcddr (x val) (setf (cdr (cdr x)) val))
(defsetf cddr %setcddr)
(defsetf elt setelt)
(defsetf aref _set-aref)
(defun svref (vec index) (elt vec index))
(defun _setsvref (vec index val) (setelt vec index val))
(defsetf svref _setsvref)
(defsetf get putprop)
(defsetf gethash addhash)
(defsetf fill-pointer _set_fill_pointer)
(defun %setfirst (s x) (setelt s 0 x))
(defsetf first %setfirst)
(defun %setsecond (s x) (setelt s 1 x))
(defsetf second %setsecond)
(defun %setthird (s x) (setelt s 2 x))
(defsetf third %setthird)
(defun %setfourth (s x) (setelt s 3 x))
(defsetf fourth %setfourth)
(defun %setfifth (s x) (setelt s 4 x))
(defsetf fifth %setfifth)
(defun %setsixth (s x) (setelt s 5 x))
(defsetf sixth %setsixth)
(defun %setseventh (s x) (setelt s 6 x))
(defsetf seventh %setseventh)
(defun %seteighth (s x) (setelt s 7 x))
(defsetf eighth %seteighth)
(defun %setninth (s x) (setelt s 8 x))
(defsetf ninth %setninth)
(defun %settenth (s x) (setelt s 9 x))
(defsetf tenth %settenth)
;
;    constants for Common Lisp
(defconstant array-rank-limit 8)
(defconstant array-dimension-limit 2147483647)
(defconstant array-total-size-limit 2147483647)
(defconstant internal-time-units-per-second 1000000)
(defconstant pi 3.14159265358979323846)

(defvar *load-verbose* nil)
(defvar *load-print* nil)
(defvar *error-output* *terminal-io*)

(defun %is-binary (input-stream)
    (let ((x (read-byte input-stream)))
        (file-position input-stream 0)
        (return (= x 0))))

(defun load (filename
        &key (verbose *load-verbose*)
             (print *load-print*)
             if-does-not-exist)
    (let*
        ((loaded 0)
         (stream nil)
         (binary nil)
         (message (format nil "Loading file ~A…" filename))
         (*package* *package*)            ;; bind these to themselves
         (*readtable* *readtable*)
         (*standard-output* *standard-output*))

        (if (symbolp filename)
            (setq filename (symbol-name filename)))
        (if (streamp filename)
            (setq stream filename)
            (if (not (stringp filename))
                (error "Invalid file name")))

        (unless stream (setq stream (open filename)))
        (setq binary (%is-binary stream))

        (if binary
            (progn
                (if verbose
                    (progn
                        (format t ";;~%")
                        (format t ";; Loading compiled file: ~A~%" filename)
                        (format t ";;~%")))

                (do* ((expr t) (symbol-table (make-array 500)))
                    ((null expr)(close stream)(return-from load loaded))
                    (editor-message message)
                    (setq expr (%read-code-from-stream stream symbol-table))
                    (if expr
                        (let ((result (funcall expr)))
                            (if print (print result))
                            (incf loaded))))))

        (if verbose
            (progn
                (format t ";;~%")
                (format t ";; Loading file: ~A~%" filename)
                (format t ";;~%")))

        (do* ((expr nil))
            ((eq expr 'Eof)(close stream)(return-from load loaded))
            (editor-message message)
            (setq expr (read stream nil))
            (if (not (eq expr 'Eof))
                (progn
                    (setq expr (eval expr))
                    (if print (print expr))
                    (incf loaded))))))

;;
;;    Common Lisp 'defun' macro.
;;    This redefines the built-in special form.
;;
(defmacro defun (name lambda-list &rest forms)
    (let ((doc-form nil)
          (lambda-form nil)
          (declarations nil))

        ;; look for declarations and doc string
        (do* ((f forms (cdr f)))
            ((null f) (setq forms f))
            (if (and (typep (car f) 'string) (null doc-form) (cdr f))
                (setq doc-form
                    `((setf (documentation ',name 'function) ,(car f))))
                (if (and (consp (car f)) (eq (caar f) 'declare))
                    (push (car f) declarations)
                    (progn (setq forms f) (return)))))

        (setq lambda-form
            `(lambda ,lambda-list ,@(nreverse declarations)
                (block ,name ,@forms)))
        `(progn
            ,@doc-form
            (setf (symbol-function ',name) (function ,lambda-form))
            ',name)))

;;
;;    Common Lisp 'defmacro' macro.
;;    This redefines the built-in special form.
;;
(defmacro defmacro (name lambda-list &rest forms)
    (let ((doc-form nil)
          (lambda-form nil)
          (declarations nil))

        ;; look for declarations and doc string
        (do* ((f forms (cdr f)))
            ((null f) (setq forms f))
            (if (and (typep (car f) 'string) (null doc-form) (cdr f))
                (setq doc-form
                    `((setf (documentation ',name 'macro) ,(car f))))
                (if (and (consp (car f)) (eq (caar f) 'declare))
                    (push (car f) declarations)
                    (progn (setq forms f) (return)))))

        (setq lambda-form
            `(lambda (form &optional env)
                (destructuring-bind ,lambda-list
                    (cdr form)
                    ,@(nreverse declarations)
                    (block ,name ,@forms))))
        `(progn
            ,@doc-form
            (setf (macro-function ',name) (function ,lambda-form))
            ',name)))


;;
;;    Common Lisp 'deftype' macro.
;;
(defmacro deftype (name lambda-list &rest forms)
    (let ((doc-form nil) (lambda-form nil))
        (if (and (typep (car forms) 'string) (cdr forms))
            (progn
                (setq doc-form
                    `((setf (documentation ',name 'type) ,(car forms))))
                (setq forms (cdr forms))))

        (setq lambda-form
            `(lambda (form &optional env)
                (type-destructuring-bind ,lambda-list
                    (cdr form)
                    (block ,name ,@forms))))
        `(progn
            ,@doc-form
            (setf (get ',name '_type_expansion_) (function ,lambda-form))
            (null-environment (get ',name '_type_expansion_))
            ',name)))

;
;    Common Lisp 'defstruct' macro.
;
(defmacro defstruct (name-and-options &rest doc-and-slots)
    (require :structures)        ;; load module
    `(defstruct ,name-and-options ,@doc-and-slots))

;
;    Common Lisp 'defpackage' macro.
;
(defmacro defpackage (name &rest options)
    (require :defpackage)        ;; load module
    `(defpackage ,name ,@options))

;
;    Common Lisp 'in-package' macro
;
(defmacro in-package (name)
    `(eval-when (:load-toplevel :compile-toplevel :execute)
        (let ((package (find-package ,name)))
            (if package
                (setq *package* package)
                (setq *package* (make-package ,name))))))

;
;    Common Lisp 'time' macro.
;
;
(defmacro time (x)
    `(let ((tm (get-internal-run-time)) ret)
        (setq ret ,x)
        (setq tm (- (get-internal-run-time) tm))
        (decf tm (%elapsed-time nil))    ;; subtract timer overhead
        (setq tm (/ (float tm) 1000000.0))
        (format *trace-output* "Execution time: ~A seconds~%" tm)
        ret))

; This private macro '%elapsed-time' acts like time, but returns the
; time elapsed after evaluating the passed expression.
;
(defmacro %elapsed-time (x)
    `(let ((tm (get-internal-run-time)) ret)
        (setq ret ,x)
        (setq tm (- (get-internal-run-time) tm))
        tm))

;;;    Some standard predicates
(defun functionp (x)     (typep x 'function))
(defun keywordp (x)     (typep x 'keyword))
(defun arrayp (x)         (typep x 'array))
(defun packagep (x)     (typep x 'package))
(defun bit-vector-p (x) (typep x 'bit-vector))

;
;    Common Lisp 'string' function.
;
(defun string (x)
    (cond
        ((stringp x) x)
        ((symbolp x) (symbol-name x))
        ((characterp x)
         (let ((string " ")) (setf (elt string 0) x) string))))

;
;    Common Lisp 'position' function.
;
(defun position (item sequence
        &key from-end (test #'eql) test-not (start 0) end key)
    (unless (typep sequence 'sequence)
        (error "Not a sequence: ~A" sequence))
    (unless (integerp end)
        (setq end (length sequence)))
    (if test-not (setq test #'(lambda (x y) (not (funcall test-not x y)))))

    (if from-end
        ;; loop backward
        (do ((i (1- end) (- i 1))
             (x))
            ((< i start) nil)
            (setq x (elt sequence i))
            (if key (setq x (funcall key x)))
            (if (funcall test item x)
                (return i)))

        ;;; else go forward
        (do ((i start (+ i 1))
             (x))
            ((>= i end) nil)
            (setq x (elt sequence i))
            (if key (setq x (funcall key x)))
            (if (funcall test item x)
                (return i)))))

;
;    Common Lisp 'position-if' function.
;
(defun position-if (test sequence
        &key from-end (start 0) end key)
    (unless (typep sequence 'sequence)
        (error "Not a sequence: ~A" sequence))
    (unless (functionp test)
        (error "Not a function: ~A" test))
    (unless (integerp end)
        (setq end (length sequence)))

    (if from-end
        ;; loop backward
        (do ((i (1- end) (- i 1))
             (x))
            ((< i start) nil)
            (setq x (elt sequence i))
            (if key (setq x (funcall key x)))
            (if (funcall test x)
                (return i)))

        ;;; else go forward
        (do ((i start (+ i 1))
             (x))
            ((>= i end) nil)
            (setq x (elt sequence i))
            (if key (setq x (funcall key x)))
            (if (funcall test x)
                (return i)))))

;
;    Common Lisp 'position-if-not' function.
;
(defun position-if-not (test sequence
        &key from-end (start 0) end key)
    (unless (typep sequence 'sequence)
        (error "Not a sequence: ~A" sequence))
    (unless (functionp test)
        (error "Not a function: ~A" test))
    (unless (integerp end)
        (setq end (length sequence)))

    (if from-end
        ;; loop backward
        (do ((i (1- end) (- i 1))
             (x))
            ((< i start) nil)
            (setq x (elt sequence i))
            (if key (setq x (funcall key x)))
            (if (not (funcall test x))
                (return i)))

        ;;; else go forward
        (do ((i start (+ i 1))
             (x))
            ((>= i end) nil)
            (setq x (elt sequence i))
            (if key (setq x (funcall key x)))
            (if (not (funcall test x))
                (return i)))))

;
;    Common Lisp 'find' function.
;
(defun find (item sequence
        &key from-end (test #'eql) test-not (start 0) end key)
    (unless (typep sequence 'sequence)
        (error "Not a sequence: ~A" sequence))
    (unless (integerp end)
        (setq end (length sequence)))
    (if test-not (setq test #'(lambda (x y) (not (funcall test-not x y)))))

    (if from-end
        ;; loop backward
        (do ((i (1- end) (- i 1))
             (x))
            ((< i start) nil)
            (setq x (elt sequence i))
            (if key (setq x (funcall key x)))
            (if (funcall test item x)
                (return x)))

        ;;; else go forward
        (do ((i start (+ i 1))
             (x))
            ((>= i end) nil)
            (setq x (elt sequence i))
            (if key (setq x (funcall key x)))
            (if (funcall test item x)
                (return x)))))

;
;    Common Lisp 'find-if' function.
;
(defun find-if (test sequence
        &key from-end (start 0) end key)
    (unless (typep sequence 'sequence)
        (error "Not a sequence: ~A" sequence))
    (unless (functionp test)
        (error "Not a function: ~A" test))
    (unless (integerp end)
        (setq end (length sequence)))

    (if from-end
        ;; loop backward
        (do ((i (1- end) (- i 1))
             (x))
            ((< i start) nil)
            (setq x (elt sequence i))
            (if key (setq x (funcall key x)))
            (if (funcall test x)
                (return x)))

        ;;; else go forward
        (do ((i start (+ i 1))
             (x))
            ((>= i end) nil)
            (setq x (elt sequence i))
            (if key (setq x (funcall key x)))
            (if (funcall test x)
                (return x)))))

;
;    Common Lisp 'find-if-not' function.
;
(defun find-if-not (test sequence
        &key from-end (start 0) end key)
    (unless (typep sequence 'sequence)
        (error "Not a sequence: ~A" sequence))
    (unless (functionp test)
        (error "Not a function: ~A" test))
    (unless (integerp end)
        (setq end (length sequence)))

    (if from-end
        ;; loop backward
        (do ((i (1- end) (- i 1))
             (x))
            ((< i start) nil)
            (setq x (elt sequence i))
            (if key (setq x (funcall key x)))
            (if (not (funcall test x))
                (return x)))

        ;;; else go forward
        (do ((i start (+ i 1))
             (x))
            ((>= i end) nil)
            (setq x (elt sequence i))
            (if key (setq x (funcall key x)))
            (if (not (funcall test x))
                (return x)))))

;
;    Common Lisp 'count' function.
;
(defun count (item sequence
        &key from-end (test #'eql) test-not (start 0) end key)
    (unless (typep sequence 'sequence)
        (error "Not a sequence: ~A" sequence))
    (unless (integerp end)
        (setq end (length sequence)))
    (if test-not (setq test #'(lambda (x y) (not (funcall test-not x y)))))

    ;; we can ignore the :from-end key
    (if key
        (do ((i start (+ i 1))
              (count 0))
            ((>= i end) count)
            (if (funcall test (funcall key (elt sequence i)) item)
                (incf count)))
        ;; else
        (do ((i start (+ i 1))
              (count 0))
            ((>= i end) count)
            (if (funcall test (elt sequence i) item)
                (incf count)))))

;
;    Common Lisp 'count-if' function.
;
(defun count-if (test sequence
        &key from-end (start 0) end key)
    (unless (typep sequence 'sequence)
        (error "Not a sequence: ~A" sequence))
    (unless (functionp test)
        (error "Not a function: ~A" test))
    (unless (integerp end)
        (setq end (length sequence)))

    ;; we can ignore the :from-end key
    (if key
        (do ((i start (+ i 1))
              (count 0))
            ((>= i end) count)
            (if (funcall test (funcall key (elt sequence i)))
                (incf count)))
        ;; else
        (do ((i start (+ i 1))
              (count 0))
            ((>= i end) count)
            (if (funcall test (elt sequence i))
                (incf count)))))

;
;    Common Lisp 'count-if-not' function.
;
(defun count-if-not (test sequence
        &key from-end (start 0) end key)
    (unless (typep sequence 'sequence)
        (error "Not a sequence: ~A" sequence))
    (unless (functionp test)
        (error "Not a function: ~A" test))
    (unless (integerp end)
        (setq end (length sequence)))

    ;; we can ignore the :from-end key
    (if key
        (do ((i start (+ i 1))
              (count 0))
            ((>= i end) count)
            (if (not (funcall test (funcall key (elt sequence i))))
                (incf count)))
        ;; else
        (do ((i start (+ i 1))
              (count 0))
            ((>= i end) count)
            (if (not (funcall test (elt sequence i)))
                (incf count)))))

;
;    Common Lisp 'fill' function.
;
(defun fill (sequence item &key (start 0) end)
    (unless (typep sequence 'sequence)
        (error "Not a sequence: ~A" sequence))
    (unless (integerp end)
        (setq end (length sequence)))
    (dotimes (i (- end start))
        (setf (elt sequence (+ i start)) item))
    sequence)

;
;    Common Lisp 'replace' function.
;
(defun replace (sequence1 sequence2 &key (start1 0) end1 (start2 0) end2)
    (unless (typep sequence1 'sequence)
        (error "Not a sequence: ~A" sequence1))
    (unless (typep sequence2 'sequence)
        (error "Not a sequence: ~A" sequence2))
    (unless (integerp end1)
        (setq end1 (length sequence1)))
    (unless (integerp end2)
        (setq end2 (length sequence2)))
    (dotimes (i (min (- end1 start1) (- end2 start2)))
        (setf (elt sequence1 (+ i start1)) (elt sequence2 (+ i start2))))
    sequence1)

;
;    Common Lisp 'mismatch' function.
;
(defun mismatch (sequence1 sequence2
        &key (from-end nil)
             (test #'eql)
             (test-not nil)
             (key nil)
             (start1 0)
             (start2 0)
             (end1 (length sequence1))
             (end2 (length sequence2)))

    (unless (typep sequence1 'sequence)
        (error "Not a sequence: ~A" sequence1))
    (unless (typep sequence2 'sequence)
        (error "Not a sequence: ~A" sequence2))
    (if test-not (setq test #'(lambda (x y) (not (funcall test-not x y)))))

    (if from-end
        ;; loop backward
        (do* ((i1 start1 (1+ i1))
              (i2 start2 (1+ i2))
              x1 x2)
            ((and (>= i1 end1) (>= i2 end2)) nil)
            (if (>= i1 end1) (return i1))
            (if (>= i2 end2) (return i1))
            (setq x1 (elt sequence1 i1))
            (setq x2 (elt sequence2 i2))
            (if key
                (progn
                    (setq x1 (funcall key x1))
                    (setq x2 (funcall key x2))))
            (unless (funcall test x1 x2)
                (return i1)))

        ;;; else go forward
        (do* ((i1 start1 (1+ i1))
              (i2 start2 (1+ i2))
              x1 x2)
            ((and (>= i1 end1) (>= i2 end2)) nil)
            (if (>= i1 end1) (return i1))
            (if (>= i2 end2) (return i1))
            (setq x1 (elt sequence1 i1))
            (setq x2 (elt sequence2 i2))
            (if key
                (progn
                    (setq x1 (funcall key x1))
                    (setq x2 (funcall key x2))))
            (unless (funcall test x1 x2)
                (return i1)))))

;
;    Common Lisp 'search' function.
;
(defun search (sequence1 sequence2
        &key (from-end nil)
             (test #'eql)
             (test-not nil)
             (key nil)
             (start1 0)
             (start2 0)
             (end1 (length sequence1))
             (end2 (length sequence2)))

    (unless (typep sequence1 'sequence)
        (error "Not a sequence: ~A" sequence1))
    (unless (typep sequence2 'sequence)
        (error "Not a sequence: ~A" sequence2))
    (if test-not (setq test #'(lambda (x y) (not (funcall test-not x y)))))

    (if from-end
        ;; loop backward
        (do* ((i (1- end2) (1- i))
              compare)
            ((< i start2) nil)
            (setq compare (mismatch sequence1 sequence2 :test test
                    :key key :start1 start1 :end1 end1 :start2 i))
            (if (or (null compare) (>= compare end1))
                (return i)))

        ;;; else go forward
        (do* ((i start2 (1+ i))
              compare)
            ((>= i end2) nil)
            (setq compare (mismatch sequence1 sequence2 :test test
                    :key key :start1 start1 :end1 end1 :start2 i))
            (if (or (null compare) (>= compare end1))
                (return i)))))

;
;    Common Lisp 'prin1' function.
;
(defun prin1 (object &optional (output-stream *standard-output*))
    (write object :stream output-stream :escape t))

;
;    Common Lisp 'print' function.
;
(defun print (object &optional (output-stream *standard-output*))
    (terpri output-stream)
    (prin1 object output-stream)
    (prin1 #\Space output-stream))

;
;    Common Lisp 'princ' function.
;
(defun princ (object &optional (output-stream *standard-output*))
    (write object :stream output-stream :escape nil))

;
;    Common Lisp 'mapcan' function.
;
(defun mapcan (func list &rest more-lists)
    (apply #'nconc (apply #'mapcar (cons func (cons list more-lists)))))

;
;    Common Lisp 'mapcon' function.
;
(defun mapcon (func list &rest more-lists)
    (apply #'nconc (apply #'maplist (cons func (cons list more-lists)))))

(defun copy-alist (alist)
    (let ((newlist nil))
        (dolist (n alist)
            (push
                (if (consp n)
                    (cons (car n) (cdr n))
                    n)
                newlist))
        (nreverse newlist)))

;
;    Common Lisp 'read-from-string' function.
;    To do: handle eof-error, eof-value, preserve-whitespace settings
;
(defun read-from-string (string &optional eof-error eof-value
            &key (start 0) end preserve-whitespace
            &aux string-stream expr position)
    (if (not (typep string 'string)) (error "Not a string"))
    (if (not end) (setq end (length string)))
    (setq string-stream (make-string-input-stream string start end))
    (setq expr (read string-stream))
    (setq position (file-position string-stream))
    (if (eq position 'Eof) (setq position (- end start)))
    (values expr position))

;
;    Common Lisp 'with-output-to-string' macro.
;
(defmacro with-output-to-string ((var &optional string) &rest forms)
    `(let ((,var (make-string-output-stream)) (ret ,string) string)
        (unwind-protect
            (progn
                (let ()        ; establish a let block to allow declarations
                    ,@forms)
                (setq string (get-output-stream-string ,var))
                (if ret
                    (dotimes (i (length string))
                        (vector-push-extend (elt string i) ret))
                    (setq ret string)))
            (close ,var))
        ret))

;;
;;    Normal top level user input function.
;;    This will get executed at startup and for the duration of an
;;    interactive session.
;;    By default, this function is the value of the variable *top-level*.
;;
(defun top-level ()
    (do (expr)
        (nil)
        (catch 'common-lisp::%error
            (progn
                (setq *read-level* 0)
                (setq expr (read))
                (if (eq expr 'quit)
                    (return))
                (if (eq expr 'Eof)
                    (return 'Eof))
                (editor-message "Thinking…")    ;; display status message
                (setq expr (multiple-value-list (eval expr)))
                (format t "~A~{ ~A~}~%" (car expr) (cdr expr))))))

(setq *top-level* #'common-lisp::top-level)

;
;    Common Lisp 'identity' function.
;
(defun identity (object) object)

(defun finish-output (&optional (stream *standard-output*))
    (file-flush stream))

(defun force-output (&optional (stream *standard-output*))
    (file-flush stream))

(defun clear-output (&optional (stream *standard-output*))
    (file-flush stream))

(defun parse-integer (string
        &key (start 0)
             (end (length string))
             (radix 10)
             (junk-allowed nil)
        &aux (result 0)
             (state :initial)
             (sign 1)
             c)

    ;; check for leading sign
    (setf c (char string start))
    (if (char= c #\-)
        (progn (setf sign -1) (incf start))
        (if (char= c #\+)
            (incf start)))

    (do* ((i start (+ i 1))
          (n 0))
        ((>= i end))
        (setq c (char string i))
        (setq n (digit-char-p c radix))
        (cond
            (n (progn
                (cond
                    ((eq state :finished)
                     (if (not junk-allowed)
                        (error "Invalid integer parsed: ~A" string)
                        (progn (setq end i) (return)))))
                (setq result (+ (* result radix) n))
                (setq state :collecting)))

            ((member c '(#\Newline #\Space #\Tab))
                (cond
                    ((eq state :collecting) (setq state :finished))
                    ((eq state :initial) nil)    ; don't do anything
                    ((eq state :finished) nil)))
            (t
                (if (not junk-allowed)
                    (error "Invalid integer parsed: ~A" string)
                    (progn (setq end i) (return))))))

    (if (eq state :initial)
        (setq result nil)
        (setq result (* result sign)))
    (values result end))


;;; load the backquote facility
(require :backquote)        ; cause this to be loaded now

;;; load the format facility
(require :format)            ; cause this to be loaded now

; (require :cl-working)        ; additional stuff

;
;    This allows the #{ (assembly code) } syntax
;
(set-dispatch-macro-character #\# #\{
    #'(lambda (stream char int)
        (require :assembler)
        (let ((*package* (find-package :assembler)))
            (assemble (read-delimited-list #\} stream) nil))))

(defun defasm (&rest x)
    (error "Assembler package not loaded"))

(defun hex (x)
    (let ((*print-base* 16))
        (write x))
    (values))

(defun disassemble (a)
    (let ((*print-base* 16))
        (format t "~{~A~%~}" (disassembly-list a))))

(defun prompt ()
    (let ((savep *print-escape*))
        (setq *print-escape* nil)
        (write "free: ")
        (write (free))
        (write ">")
        (write "\n")
        (setq *print-escape* savep)))

;; Print an executable address in hex
(defun print-code (x)
    (let ((*print-base* 16))
        (print (exec-address x))))

;; Print an object address in hex
(defun print-addr (x)
    (let ((*print-base* 16))
        (print (address x))))

(defun gc-hook-default-function (nodes-freed)
    (if *gc-verbose*
        (progn
            (format t "Garbage collection: ~A nodes were freed.~%" nodes-freed)
            (file-flush))))

(defvar *gc-hook* #'gc-hook-default-function)
(defvar *gc-verbose* nil)        ;; set this to T to get garbage collection messages

(defun ffloor (number &optional (divisor 1))
    (multiple-value-bind (num div)
        (floor number divisor)
        (values (float num) div)))

(defun fceiling (number &optional (divisor 1))
    (multiple-value-bind (num div)
        (ceiling number divisor)
        (values (float num) div)))

(defun ftruncate (number &optional (divisor 1))
    (multiple-value-bind (num div)
        (truncate number divisor)
        (values (float num) div)))

(defun fround (number &optional (divisor 1))
    (multiple-value-bind (num div)
        (round number divisor)
        (values (float num) div)))

(defun get-properties (place indicator-list)
    (do ((n place (cddr n)))
        ((< (length n) 2) (values nil nil nil))
        (let ((x (member (car n) indicator-list)))
            (if x
                (return (values (car n) (cadr n) n))))))

(defun copy-symbol (sym &optional copy-props)
    (let ((new-symbol (make-symbol (symbol-name sym))))
        (if copy-props
            (progn
                (if (boundp sym)
                    (setf (symbol-value new-symbol) (symbol-value sym)))
                (setf (symbol-plist new-symbol) (copy-list (symbol-plist sym)))))
        new-symbol))

;
;    Set up the reader macro which allows for #:sym syntax
;
(set-dispatch-macro-character #\# #\:
    #'(lambda (stream char int)
        (let ((*package* nil))
            (read stream))))

(defsetf getf %setf-getf)

(defun error-stack ()
    "Usage: (error-stack)
        Prints a dump of the processor stack state when the last error
        occurred"
    (dolist (i *stack-trace*) (print i)))

(defun signum (x)
   (cond ((not (numberp x)) (error "Not a number: ~A" x))
         ((zerop x) x)
          (t (/ x (abs x)))))

(defmacro typecase (keyform &rest clauses)
    (let ((new-symbol (gensym)))
        (dolist (n clauses)
            (setf (car n) `(typep ,new-symbol ',(car n))))
        `(let ((,new-symbol ,keyform))
            (cond ,@clauses))))

(defun describe (obj)
    (require :describe)        ;; load module
    (cl::%describe obj))

(set-dispatch-macro-character #\# #\C
    #'(lambda (stream char int)
        (let* ((*read-base* 10)
               (nums (read stream)))
            (complex (car nums) (cadr nums)))))

(defun cl::%do-symbols-get-symbol ()
    (prog* (sym flag)
        loop
        (if (null *do-symbols-packages*) (return (values nil nil)))
        (multiple-value-setq (sym flag)
            (%package-next-symbol (car *do-symbols-packages*)))
        (unless flag
            (progn
                (setq *do-symbols-packages* (cdr *do-symbols-packages*))
                (if (null *do-symbols-packages*) (return (values nil nil)))
                (multiple-value-setq (sym flag)
                    (%package-first-symbol (car *do-symbols-packages*)))))
        (if flag (return (values sym t)))
        (go loop)))

(defmacro do-symbols ((var package result-form) &rest forms)
    `(let ((pk (find-package ,package))
            packs
            *do-symbols-packages*)
        (declare (special *do-symbols-packages*))
        (unless pk (setq pk *package*))
        (setq *do-symbols-packages* (cons pk (package-use-list pk)))
        (do* ((,var (%package-first-symbol pk) (cl::%do-symbols-get-symbol)))
             ((null *do-symbols-packages*) (progn (setq ,var nil) ,result-form))
             ,@forms)))

(defmacro do-all-symbols ((var result-form) &rest forms)
    `(let (*do-symbols-packages*)
        (declare (special *do-symbols-packages*))
        (setq *do-symbols-packages* (list-all-packages))
        (do* ((,var (%package-first-symbol (car *do-symbols-packages*))
                (cl::%do-symbols-get-symbol)))
             ((null *do-symbols-packages*) (progn (setq ,var nil) ,result-form))
             ,@forms)))

(defun cl::%do-external-symbols-get-symbol ()
    (prog* (sym flag)
        loop
        (if (null *do-symbols-packages*) (return (values nil nil)))
        (multiple-value-setq (sym flag)
            (%package-next-extern-symbol (car *do-symbols-packages*)))
        (unless flag
            (progn
                (setq *do-symbols-packages* (cdr *do-symbols-packages*))
                (if (null *do-symbols-packages*) (return (values nil nil)))
                (multiple-value-setq (sym flag)
                    (%package-first-extern-symbol (car *do-symbols-packages*)))))
        (if flag (return (values sym t)))
        (go loop)))

(defmacro do-external-symbols ((var package result-form) &rest forms)
    `(let ((pk (find-package ,package))
            packs
            *do-symbols-packages*)
        (declare (special *do-symbols-packages*))
        (unless pk (setq pk *package*))
        (setq *do-symbols-packages* (cons pk (package-use-list pk)))
        (do* ((,var (%package-first-extern-symbol pk)
                (cl::%do-external-symbols-get-symbol)))
             ((null *do-symbols-packages*) (progn (setq ,var nil) ,result-form))
             ,@forms)))

(defun find-all-symbols (name &aux (list nil))
    (if (symbolp name) (setq name (symbol-name name)))
    (do-all-symbols (x)
        (if (string= (symbol-name x) name) (push x list)))
    list)

;; Hyperbolic functions    Ken Whedbee  from CLtL

(defun logtest (x y) (not (zerop (logand x y))))
(defconstant imag-one #C(0.0 1.0))
(defun cis (x) (exp (* imag-one x)))

(defun asinh (x) (log (+ x (sqrt (+ 1.0 (* x x))))))
(defun acosh (x) (log (+ x (* (1+ x) (sqrt (/ (1- x) (1+ x)))))))
(defun atanh (x)
    (when (or (= x 1.0) (= x -1.0))
        (error "logarithmic singularity" x))
    (log (/ (1+ x) (sqrt (- 1.0 (* x x))))))

(defun butlast (x &optional (n 1))
    (let ((length (- (length x) n)))
        (if (minusp n)
            (error "butlast: negative index"))
        (if (<= length 0)
            nil
            (subseq x 0 length))))

(defun nbutlast (x &optional (n 1))
    (let ((length (- (length x) n)))
        (if (minusp n)
            (error "nbutlast: negative index"))
        (if (<= length 0)
            nil
            (progn
                (setf (cdr (nthcdr (1- length) x)) nil)
                x))))

(defun list-length (x)
    (do ((n 0 (+ n 2))
         (fast x (cddr fast))
         (slow x (cddr slow)))
        (nil)
        (when (endp fast) (return n))
        (when (endp (cdr fast)) (return (+ n 1)))
        (when (and (eq fast slow) (> n 0)) (return nil))))

(defun apply-arg-rotate (f args)
    (apply f (car (last args)) (butlast args)))

(defmacro defsetf (sym first &rest rest)
    (if (symbolp first)
        `(progn (cl::putprop ',sym 'cl::_setf_expansion_ ',first) ',sym)
        (let ((f `#'(lambda ,(append (car rest) first) ,@(cdr rest)))
            (args (gensym)))
            `(progn
                (setf (get ',sym 'cl::_setf_expansion_)
                    #'(lambda (&rest ,args) (apply-arg-rotate ,f ,args)))
                ',sym))))

(defsetf subseq (sequence start &optional end) (new-sequence)
    `(progn
        (replace ,sequence ,new-sequence
                :start1 ,start :end1 ,end)
        ,new-sequence))